(*
 *    _  _   ____                         _  
 *  _| || |_/ ___|  ___ _ __  _ __   ___ | | 
 * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| | 
 * |_      _|___) |  __/ |_) | |_) | (_) |_| 
 *   |_||_| |____/ \___| .__/| .__/ \___/(_) 
 *                     |_|   |_|             
 *
 * Personal Social Web.
 *
 * iweb.ml
 *
 * Copyright (C) The #Seppo contributors. All rights reserved.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)

let ( >>= )  = Result.bind
let ( let* ) = Result.bind
let chain a b =
  let f a = Ok (a, b) in
  Result.bind a f
let seppo = Uri.make ~userinfo:"seppo" ~host:"seppo.mro.name" ()

let to_channel ~xsl oc l
(** Write a xml document to a channel.
 *
 * xsl  stylesheet url
 * oc   destination
 * l    xml dom
*) =
  assert (xsl |> St.is_suffix ~affix:".xsl");
  let xsl = Some ("../themes/current/" ^ xsl)
  and readme = Some {|
The html you see here is for compatibility with https://sebsauvage.net/wiki/doku.php?id=php:shaarli

The main reason is backward compatibility for e.g. http://mro.name/ShaarliOS and
https://github.com/dimtion/Shaarlier
|} in
  Xml.to_chan ~xsl ~readme l oc

(** Redirect to work properly on /cgi-bin/ webservers. See https://seppo.mro.name/S1037
 *
 * request_uri   the requested uri
 * r             request meta data
*)
let redir_if_cgi_bin ?(request_uri = Cgi.Request.hREQUEST_URI |> Sys.getenv) (r : Cgi.Request.t) =
  assert ("/cgi-bin/" |> String.equal Cgi.cgi_bin);
  assert ("seppo.cgi" |> String.equal Cfg.seppo_cgi);
  (* Logr.debug (fun m -> m "%s.%s %s" "Iweb" "redir_if_cgi_bin" request_uri); *)
  if Str.string_match Cgi.Request.rx_cgi_bin request_uri 0
  then
    request_uri
    |> Str.matched_group 1
    |> Uri.of_string
    |> Http.s302'
    |> Result.error
  else
    Ok r

let uri2id_rel ~base id =
  id
  (*      |> Uri.pct_decode *)
  (* revert substitution by posts.xsl  *)
  |> String.map (function | '$' -> '#'
                          | c   -> c)
  |> Uri.of_string
  |> Http.abs_to_rel ~base

let pa = "../" |> Uri.of_string

(** CSRF Token *)
module Token = struct
  let fn = "app/var/run/token.s"

  (** use the uuid as token and write to fn *)
  let create ~uuid fn =
    Logr.debug(fun m -> m "%s.%s create and store %s" "Iweb.Token" "create" fn);
    (* is it ok to use the request uuid as token? *)
    let tok = uuid |> Uuidm.to_string in
    (* @TODO maybe this should only happen if not exists, could enable DOS? *)
    fn |> File.out_channel_replace (fun oc ->
        Csexp.to_channel oc (Csexp.Atom tok) );
    tok

  (** String.equal exp tok. Maybe too similar to Result.fold
   *
   * ok
   * err
   * exp
   * tok
  *)
  let validate ~ok ~err exp tok =
    if String.equal exp tok
    then Ok ok
    else err

  (** load, destroy and validate CSRF token. *)
  let check fn ((query : Html.Form.t), vv) =
    Logr.debug (fun m -> m "%s.%s" "Iweb.Token" "check");
    try
      match fn |> File.in_channel Csexp.input with
      | Ok Csexp.Atom exp ->
        Unix.unlink fn; (* @TODO maybe this should only happen in case of success, could enable DOS? *)
        let* tok = "token" |> Http.par1 (Uri.make ~query ()) in
        validate ~ok:(tok, (query,vv)) ~err:(Http.s403 ()) exp tok
      | _ -> Http.s400 ()
    with
    | Sys_error msg -> Error (Http.err500 E.e1038 msg)
end

module ClientCookie = struct
  let timeout = Cfg.ServerSession.timeout

  type t = Auth.uid

  (* payload *)
  let encode (Auth.Uid uid : t) =
    Logr.debug (fun m -> m "%s.%s" "Iweb.ClientCookie" "encode");
    Csexp.(Atom uid |> to_string)

  (* payload *)
  let decode c : (t,string) result =
    let open Csexp in
    match c |> parse_string with
    | Ok Atom uid  -> Ok (Auth.Uid uid)
    | _ -> Error "expected cookie csexp"

  let name = "#session"

  let make (req : Cgi.Request.t) v =
    Cookie.to_string
      ~domain:req.host
      ~http_only:true
      ~path:(req.script_name |> Cgi.Request.script_url)
      ~same_site:`Strict
      ~secure:false
      (name, v)

  let new_session
      ?(nonce12 = Cookie.random_nonce ())
      ?(tnow = Ptime_clock.now ())
      sec32
      req
      uid =
    let _ = tnow in
    assert (Cfg.ServerSession.l32 = (sec32 |> String.length));
    assert (Cookie.l12 = (nonce12 |> String.length));
    uid
    |> encode
    |> Cookie.encrypt sec32 nonce12
    |> make req
    |> Http.H.set_cookie
end

let xhtmlform ?(clz = "") tit name (ips : Html.Form.input list) err (dat : Html.Form.t) : _ Xmlm.frag
(** Render a complete html document with one web form.
 *
 * clz                class attribute value of the form
 * name               name attribute value of the form
 * ips                list of input fields
 * err                list of (fieldname,error-description) to be rendered into the form
 * dat                form content to prefill
 *
 * input type'textarea' => textarea
 * input type'submit'   => button
*) =
  Logr.debug (fun m -> m "%s.%s %s %s" "iWeb" "xhtmlform" name tit);
  let sep n = `Data ("\n" ^ String.make (2*n) ' ') in
  let att (n,v) = (("", n), v) in
  let ns_h = Xml.ns_xhtml in
  let field init ((nam,ty,atts) : Html.Form.input) =
    let err = err |> List.filter (fun (k,_) -> k |> String.equal nam) in
    let atts = atts |> List.fold_left (fun init a -> att a :: init) [] in
    let atts = match List.assoc_opt nam dat with
      | None   -> atts
      | Some s -> att ("value", s |> String.concat "") :: atts in
    let txt v l = `Data (l |> List.assoc_opt v |> Option.value ~default:"") in
    (* https://getbootstrap.com/docs/5.3/forms/validation/#server-side *)
    (* https://5balloons.info/bootstrap-display-invalid-feedback-server-side-validation/ *)
    let atts = match err with
      | [] -> atts
      | _ -> "is-invalid" |> Html.add_class atts in
    let ret = init in
    let ret = err
              |> List.fold_left (fun init (_,er)->
                  (* https://5balloons.info/bootstrap-display-invalid-feedback-server-side-validation/ *)
                  sep 2
                  :: `El (((ns_h,"div"),
                           [att ("role","alert");
                            att ("data-for", nam); ]),
                          [`Data er])
                  :: init) ret in
    let ret = sep 2 ::
              (match ty with
               (* type is abused to mark textarea. Here we put it right again. *)
               | "textarea" ->  let atts' = atts |> List.remove_assoc ("","value") in
                 `El (((ns_h,"textarea"), (("","name"),nam) :: atts'), [txt ("","value") atts] )
               | "submit"   -> `El (((ns_h,"button"), (("","name"),nam) :: (("","type"),ty) :: atts), [txt ("","value") atts])
               | _          -> `El (((ns_h,"input"),  (("","name"),nam) :: (("","type"),ty) :: atts), []))
              :: ret in
    ret
  in
  `El (((ns_h,"html"),
        ((Xmlm.ns_xml,"base"),"../")
        :: ((Xmlm.ns_xmlns,"xmlns"), ns_h)
        :: []),
       sep 0
       :: `El (((ns_h,"head"),[]),
               sep 1  :: `El (((ns_h,"link"), [(("","rel"),"icon"); (("","type"),"image/jpg"); (("","href"),"../me-avatar.jpg")] ),[])
               :: sep 1 :: `El (((ns_h,"meta"), [(("","name"),"generator"); (("","content"),St.seppo_s)] ),[])
               :: sep 1 :: `El (((ns_h,"title"), []),[`Data tit])
               :: [])
       :: sep 0
       :: `El (((ns_h,"body"),[]),
               sep 1
               :: `El (((ns_h,"form"),
                        [(("","method"),"post");
                         (("","name"),name);
                         (("","id"),name);
                         (("","class"),clz)] ),
                       (ips |> List.rev |> List.fold_left field []) )
               :: sep 0 :: [])
       :: sep 0 :: [])

let (let*%) = Http.(let*%)

(** HTTP endpoint for ping and loop (Main.Queue). *)
module Ping = struct
  (** HTTP GET handler to receive a ping.
   *
   * evtl trigger the Main.Queue *)
  let get ~base _uuid now (r : Cgi.Request.t) =
    if now |> Cron.has_fresh_lockfile
    then
      Http.s400 () |> Lwt.return
    else
      let base : Uri.t = base () in
      let run_delay_s = 60 in
      let key_id = Ap.Person.my_key_id ~base in
      let*% pk = Ap.PubKeyPem.(private_of_pem pk_pem)
                 |> Result.map_error (fun e ->
                     Logr.warn (fun m -> m "%s.%s %s" "Iweb.Ping" "get" e);
                     Http.s500' ) in
      let key   = Http.Signature.mkey ~now key_id pk in
      (* @todo check r if signed by the same key *)
      match r.query_string |> Uri.query_of_encoded with
      | []
      | ["",[]]
      | [("nudge",_)] ->
        Main.Queue.http_ping_and_forget ~base ~key ~run_delay_s
      | [("loop",_)] -> Main.Queue.(loop ~base ~key ~run_delay_s (process_new_and_due ~base ~key))
      | _            -> Http.s400 () |> Lwt.return
end

(* combine name and value *)
let n ((n,_,_) : Html.Form.input) (v : string) : Html.Form.field = (n,[v])

(** Web UI for login. *)
module Login = struct
  let path = "/login"
  module F = Html.Form

  let i_tok : F.input = ("token",              "hidden",   [])
  let i_uid : F.input = ("login",              "text",     ["required","required"; "autofocus","autofocus"])
  let i_pwd : F.input = ("password",           "password", ["required","required"])
  let i_lol : F.input = ("longlastingsession", "checkbox", [])
  let i_ret : F.input = ("returnurl",          "hidden",   [])
  let i_but : F.input = ("Login",              "submit",   [])

  (** Handler for HTTP GET *)
  let get _uuid (tok, (r : Cgi.Request.t)) =
    Logr.debug (fun m -> m "%s.%s" "Iweb.Login" "get");
    Ok (`OK, [Http.H.ct_xml], (fun oc ->
        let ur = Uri.make ~query:(r.query_string |> Uri.query_of_encoded) () in
        [
          n i_tok tok;
          n i_ret ("returnurl" |> Uri.get_query_param ur |> Option.value ~default:"");
          n i_but "Login";
        ]
        |> xhtmlform "👋 Login" "loginform" [i_tok;i_uid;i_pwd;i_lol;i_ret;i_but] []
        |> to_channel ~xsl:"loginform.xsl" oc))

  (** Handler for HTTP POST
   *
   * check uid+pwd, Always take at least 2 seconds, if ok set session cookie and
   * redirect to returnurl, call ban_f otherwise. *)
  let post uuid tnow (ban_f : Ptime.t -> string -> unit) (_tok, (frm, (req : Cgi.Request.t))) =
    let sleep = 2 in
    Logr.debug (fun m -> m "%s.%s sleep %d seconds" "Iweb.Login" "post" sleep);
    Unix.sleep sleep;
    let flt r = function
      | (("login", [_]) as v)
      | (("password", [_]) as v)
      | (("returnurl", [_]) as v)
      | (("token", [_]) as v) -> r |> List.cons v
      | (f, _) -> Logr.info (fun m -> m "unconsumed form field: '%s'" f); r
    and cmp (a, _) (b, _) = String.compare a b in
    match frm |> List.fold_left flt [] |> List.sort cmp with
    | [ ("login", [uid]);
        ("password", [pwd]);
        ("returnurl", [retu]);
        ("token", [_] (* token has to be already checked by the caller. *)); ] ->
      let start_session uid =
        let* _,sec32 = Cfg.ServerSession.(tnow |> create)
                       |> Option.to_result ~none:(Http.s403' ()) in
        let sec32 : string = sec32 in
        let cv =  ClientCookie.new_session ~tnow sec32 req uid in
        Logr.info (fun m -> m "%s.%s success! redirect to '%s'" "Iweb.Login" "post" retu);
        retu |> Uri.of_string |> Http.s302 ~header:[ cv ]
      in
      Ok (Auth.Uid uid, pwd)
      >>= Auth.chk_file Auth.fn |> Result.map_error (fun _ ->
          ban_f tnow req.remote_addr;
          let tok = Token.(create ~uuid fn) in
          (`Unauthorized, [Http.H.ct_xml], (fun oc ->
               let ee = [
                 "login","invalid username or password";
                 "password","invalid username or password";
               ] in
               [
                 n i_tok tok;
                 n i_uid uid;
                 n i_but "Login";
                 n i_ret retu;
               ]
               |> xhtmlform "👋 Login" "loginform" [i_tok;i_uid;i_pwd;i_lol;i_ret;i_but] ee
               |> to_channel ~xsl:"loginform.xsl" oc))
        )
      >>= start_session
    | _ ->
      Http.s401 ()
end

module Logout = struct
  let path = "/logout"

  (* GET requests should be idempotent, have no side effects.
     TODO: We could use a form button for this and POST: https://stackoverflow.com/a/33880971/349514*)
  let get _uuid ((_ : Auth.uid option), req) =
    Cfg.ServerSession.delete_session ();
    pa |> Http.s302 ~header:[ ClientCookie.make req "" |> Http.H.set_cookie ]
end

(** get uid from browser session if still running *)
let ases tnow (r : Cgi.Request.t) =
  Logr.debug (fun m -> m "%s.%s" "Iweb" "ases");
  let uid = function
    (* check if the session cookie carries a date in the future *)
    | ("#session" as n, pay) :: [] ->
      assert (n = ClientCookie.name);
      (match Cfg.ServerSession.(fn |> from_file) with
       | Error s -> Logr.debug (fun m -> m "%s.%s error: %s" "Iweb" "ases" s);
         None
       | Ok sec ->
         Option.bind
           (Cfg.ServerSession.valid_secret tnow sec)
           (fun sec ->
              Option.bind
                (Cookie.decrypt sec pay)
                (fun c ->
                   match c |> ClientCookie.decode with
                   | Ok (Auth.Uid u as uid) ->
                     Logr.debug (fun m -> m "%s.%s cookie value '%s'" "Iweb" "ases" u);
                     Some uid
                   | Error s ->
                     Logr.warn (fun m -> m "%s.%s session cookie decode error: %s" "Iweb" "ases.uid" s);
                     None
                )))
    | _ ->
      Logr.warn (fun m -> m "%s.%s %s cookie not found." "Iweb" "ases" ClientCookie.name);
      None
  in
  Ok (r.http_cookie |> Cookie.of_string |> uid, r)

let rz = Webfinger.Server.rule
         :: Webfinger.rule
         :: Ap.Person.rule
         :: Ap.PersonX.rule
         :: Ap.PubKeyPem.pk_rule
         :: Ap.PubKeyPem.rule
         :: []

(** Web UI for password change. *)
module Passwd = struct
  let path = "/passwd"
  module F = Html.Form

  let i_tok : F.input = ("token", "hidden", [])
  let i_uid : F.input = ("setlogin", "text", [
      ("required","required");
      ("autofocus","autofocus");
      ("maxlength","50");
      ("minlength","1");
      ("pattern", {|^[a-zA-Z0-9_.\-]+$|});
      ("placeholder","Your local name as 'alice' in @alice@example.org");
    ])
  let i_pwd : F.input = ("setpassword", "password", [
      ("required","required");
      ("maxlength","200");
      ("minlength","12");
      ("pattern", {|^\S([^\n\t]*\S)?$|});
      ("placeholder","good passwords: xkcd.com/936");
    ])
  let i_pw2 : F.input = ("confirmpassword", "password", [
      ("required","required");
      ("placeholder","the same once more");
    ])
  let i_but : F.input = ("Save", "submit", [])

  (** Handler for HTTP GET *)
  let get _uuid (token, (Auth.Uid uid, _req)) =
    let _need_uid = Auth.(is_setup fn) in
    Ok (`OK, [Http.H.ct_xml], (fun oc ->
        [
          n i_tok token;
          n i_uid uid;
          n i_but "Save";
        ]
        |> xhtmlform "🌻 Change Password" "changepasswordform" [i_tok;i_uid;i_pwd;i_pw2;i_but] []
        |> to_channel ~xsl:"changepasswordform.xsl" oc))

  (** Handler for HTTP POST
   *
   * check uid+pwd.
  *)
  let post uuid tnow (_tok, (frm, (Auth.Uid _uid, (req : Cgi.Request.t)))) =
    Logr.debug (fun m -> m "Iweb.Passwd.post form name='%s'" "changepasswordform");
    assert (Http.Mime.app_form_url = req.content_type);
    let run() =
      (* funnel additional err messages into the form *)
      let err msg (name,_,_) pred = if pred
        then Ok ()
        else Error (name,msg) in
      let* uid = F.string i_uid frm in
      let* _ = (_uid |> String.equal "" || uid |> String.equal _uid) |> err ("Change not supported yet, please use the previous one.") i_uid in
      let* pwd = F.string i_pwd frm in
      let* pw2 = F.string i_pw2 frm in
      let (iin,_,_) = i_pwd in
      let* _ = String.equal pwd pw2 |> err ("must be identical to field '" ^ iin ^ "' but isn't") i_pw2 in
      Ok (Auth.Uid uid,pwd)
    in
    match run() with
    | Ok (uid,pwd) ->
      let* (_,sec) = Cfg.ServerSession.create tnow |> Option.to_result ~none:Http.s500' in
      let* _ = (uid, pwd) |> Auth.(to_file fn) in
      let* _ = req |> Cgi.Request.base |> Cfg.Base.(to_file fn) |> Result.map_error (Http.err500 "failed to save baseurl") in
      let* _ = Webfinger.Server.(Make.make rz rule.target) |> Result.map_error (Http.err500 "failed to update webfinger") in
      let* _ = Ap.PersonX.(Make.make rz rule.target) |> Result.map_error (Http.err500 "failed to update profile") in
      let header = [ ClientCookie.new_session sec req (uid) ] in
      pa |> Http.s302 ~header
    | Error (nam,msg as ee) ->
      Logr.warn (fun m -> m "%s %s.%s %s: %s" E.e1022 "Iweb.Passwd" "post" nam msg);
      Ok (`Unprocessable_entity, [Http.H.ct_xml], (fun oc ->
          let token = Token.(create ~uuid fn) in
          [
            n i_tok token;
            n i_uid "";
            n i_but "Save";
          ]
          |> xhtmlform "🌻 Change Password" "changepasswordform" [i_tok;i_uid;i_pwd;i_pw2;i_but] [ee]
          |> to_channel ~xsl:"changepasswordform.xsl" oc))
end

(** if no uid (= no active session) then redirect to login/passwd page *)
let uid_redir x : (Auth.uid * Cgi.Request.t, Cgi.Response.t) result =
  Logr.debug (fun m -> m "%s.%s" "Iweb" "uid_redir");
  match x with
  | (Some uid, r) -> Ok (uid, r)
  | (None, (r : Cgi.Request.t)) ->
    let r302 p =
      let path = (r.script_name |> Cgi.Request.script_url) ^ p in
      let query = ["returnurl", [r |> Cgi.Request.abs |> Uri.to_string] ] in
      Uri.make ~path ~query () |> Http.s302
    in
    if Auth.(is_setup fn)
    then r302 Login.path
    else if Passwd.path = r.path_info
    then (
      Logr.info (fun m -> m "passwd are not set, so go on with an empty uid. %s" r.path_info);
      Ok (Auth.dummy, r))
    else r302 Passwd.path

(** HTTP endpoint for Profile documents and (un)follow/(un)block. *)
module Actor = struct
  let path = "/" ^ Ap.prox

  (** local profile view of remote actor *)
  let redir_to ?(script_name = "..") res =
    let path = script_name ^ path in
    let query = ["resource", [res |> Uri.to_string] ] in
    Uri.make ~path ~query ()
    |> Http.s302

  (** HTTP get handler.

      Prefers id (url) but falls back to webfinger (rfc7565) and comes back.

      Returns RDF (xml) with xsl transformation to view in the browser. *)
  let get ~base uuid (token, (Auth.Uid _uid, (r : Cgi.Request.t))) =
    try%lwt
      let u = Uri.make ~query:(r.query_string |> Uri.query_of_encoded) () in
      Logr.debug (fun m -> m "%s.%s %a %a" "Iweb.Actor" "get" Uuidm.pp uuid Uri.pp_hum u);
      match "resource" |> Uri.get_query_param u with
      | None   -> Http.s400 ()
                  |> Lwt.return
      | Some u -> (* dynamic, uncached remote actor profile converted to rdf *)
        Logr.err (fun m -> m "%s.%s a1" "Iweb.Actor" "get");
        let date = Ptime_clock.now () in
        let base = base () in
        let key_id = Ap.Person.my_key_id ~base in
        let*% pk = Ap.PubKeyPem.(private_of_pem pk_pem)
                   |> Result.map_error (fun e -> (`Bad_gateway, [Http.H.ct_plain], (e |> Cgi.Response.body) ) ) in
        let key = Some (Http.Signature.mkey ~now:date key_id pk) in
        let u = u |> Astring.String.trim in
        match u |> Rfc7565.of_string with
        | Ok o ->
          (* TODO: redirect to webfinger endpoint below *)
          let wk = o |> Webfinger.well_known_uri in
          let%lwt fi = wk |> Webfinger.Client.http_get ~key in
          let*% v = fi
                    |> Result.map_error (fun e -> (`Bad_gateway, [Http.H.ct_plain], (e |> Cgi.Response.body ~ee:E.e1040) ) ) in
          let*% u = v.links
                    |> As2_vocab.Types.Webfinger.self_link
                    |> Option.to_result ~none:(`Bad_gateway, [Http.H.ct_plain], "no activitypub actor url found in jrd" |> Cgi.Response.body ~ee:E.e1041 )
          in
          u
          |> redir_to
          |> Lwt.return
        | Error _ ->
          let%lwt act = u
                        |> Uri.of_string
                        |> Ap.Actor.http_get ~key in
          let*% p = act
                    |> Result.map_error (fun e -> `Bad_gateway, [Http.H.ct_plain], e |> Cgi.Response.body ~ee:E.e1042 ) in
          assert (p.id |> Uri.user |> Option.is_none);
          let toc ?(indent = None) oc doc =
            (* similar St.to_chan *)
            let o = Xmlm.make_output ~decl:false (`Channel oc) ~nl:true ~indent in
            let id x = x in
            Xmlm.output_doc_tree id o (None, doc)
          in
          Ok (`OK, [Http.H.ct_xml], (fun oc ->
              Xml.pi oc "xml" ["version","1.0"];
              Xml.pi oc "xml-stylesheet" ["type","text/xsl"; "href","../../themes/current/" ^ "actor.xsl"];
              p
              |> Ap.Person.flatten
              |> Ap.Person.Rdf.encode
                ~token:(Some token)
                ~is_in_subscribers:(Some (Ap.Followers.is_in_subscribers p.id))
                ~am_subscribed_to:(Some (Ap.Following.am_subscribed_to p.id))
                ~blocked:(Some (Ap.Following.is_blocked p.id))
                ~base
                ~lang:None
              |> toc oc))
          |> Lwt.return
    with
    | exn ->
      let s = exn |> Printexc.to_string in
      Logr.err (fun m -> m "%s.%s %s" "Iweb.Actor" "get" s);
      Http.s502 ~body:(s |> Cgi.Response.body ~ee:E.e1049) () |> Lwt.return

  (** how to react on form post data concerning subscribe/block *)
  let command uuid frm =
    Logr.debug (fun m -> m "%s.%s %a !!! " "Iweb.Actor" "post" Uuidm.pp uuid );
    (** tuples old,new *)
    let yn2 n =
      (** yes/no from field *)
      let yn n =
        match (match frm |> List.assoc_opt n with
            | Some [v] -> v |> As2.No_p_yes.of_string
            | _        -> None) with
        | Some v -> v
        | None   -> As2.No_p_yes.No
      in
      yn ("~" ^ n) , yn n in
    As2.No_p_yes.(match yn2 "am_subscribed_to",yn2 "is_blocked" with
        | (_,_)    ,(No,Yes) -> `Block
        | (No,Yes) ,(_,_)    -> `Subscribe
        | (_,No)   ,(_,_)    -> `Unsubscribe
        | (_,_)    ,(_,No)   -> `Unblock
        | _ -> `Noop
      )

  (** subscription and block changes *)
  let post
      ~(base : unit -> Uri.t)
      ?(que = Main.Queue.qn)
      ?(subscribed_to = Ap.Following.cdb)
      ?(subscribers = Ap.Followers.cdb)
      uuid tnow (_tok, ((frm : Html.Form.t), (Auth.Uid _uid, (req : Cgi.Request.t)))) =
    let dst_inbox = frm |> List.assoc_opt "inbox" |> Option.value ~default:[] |> String.concat "|" |> Uri.of_string in
    let todo_id = frm |> List.assoc "resource" |> String.concat "|" |> Uri.of_string in
    Logr.debug (fun m -> m "%s.%s %a data %a" "Iweb.Actor" "post" Uuidm.pp uuid Uri.pp_hum dst_inbox);
    let base = base () in
    let me = Uri.make ~path:Ap.proj () |> Http.reso ~base in
    let cmd = command uuid frm in
    let _nfy = subscribers (* yn2 "subscribers" *) in

    let do_unsubscribe () =
      Logr.debug (fun m -> m "%s.%s send unsubscribe %a to %a" "Iweb.Actor" "post" Uri.pp todo_id Uri.pp dst_inbox);
      let ufo = todo_id |> Ap.Following.make ~me ~inbox:dst_inbox |> Ap.Following.undo ~me in
      let _ = ufo
              |> As2_vocab.Encode.(undo (follow ~base) ~base)
              |> Main.Apjob.Notify.encode ufo.id (dst_inbox, ufo.obj.object_)
              |> Csexp.to_string
              |> Bytes.of_string
              |> Job.enqueue ~due:tnow que 0 in
      let _ = Ap.Following.remove ~cdb:subscribed_to todo_id in
      let _ = Ap.Following.Subscribed_to.Json.(Make.make [rule] target) in
      let _ = Ap.Following.Subscribed_to.Atom.(Make.make [rule] target) in
      ()
    in
    let do_unblock () =
      let _ = Ap.Following.remove ~cdb:subscribed_to todo_id in
      let _ = Ap.Following.Blocked.Json.(Make.make [rule] target) in
      let _ = Ap.Following.Blocked.Atom.(Make.make [rule] target) in
      ()
    in
    let do_subscribe () =
      Logr.debug (fun m -> m "%s.%s send subscribed_to %a to %a" "Iweb.Actor" "post" Uri.pp todo_id Uri.pp dst_inbox);
      let fo = todo_id |> Ap.Following.make ~me ~inbox:dst_inbox in
      let _ = fo
              |> As2_vocab.Encode.follow ~base
              |> Main.Apjob.Notify.encode fo.id (dst_inbox, fo.object_)
              |> Csexp.to_string
              |> Bytes.of_string
              |> Job.enqueue ~due:tnow que 0 in
      let _ = Ap.Followers.State.(Pending,tnow,dst_inbox,None,None,None)
              |> Ap.Followers.update ~cdb:subscribed_to fo.object_ in
      let _ = Ap.Following.Subscribed_to.Json.(Make.make [rule] target) in
      let _ = Ap.Following.Subscribed_to.Atom.(Make.make [rule] target) in
      let _ = Ap.Following.Blocked.Json.(Make.make [rule] target) in
      let _ = Ap.Following.Blocked.Atom.(Make.make [rule] target) in
      ()
    in
    let do_block () =
      Logr.err (fun m -> m "queue unsubscribe in case");
      Logr.err (fun m -> m "queue un-notify in case");
      let _ = Ap.Followers.State.(Blocked,tnow,dst_inbox,None,None,None)
              |> Ap.Followers.update ~cdb:subscribed_to todo_id in
      let _ = Ap.Following.remove ~cdb:subscribers todo_id in
      let _ = Ap.Following.Subscribed_to.Json.(Make.make [rule] target) in
      let _ = Ap.Following.Subscribed_to.Atom.(Make.make [rule] target) in
      let _ = Ap.Following.Blocked.Json.(Make.make [rule] target) in
      let _ = Ap.Following.Blocked.Atom.(Make.make [rule] target) in
      ()
    in
    (* do it! *)
    (match cmd with
     | `Noop        -> ()
     | `Subscribe   -> do_subscribe ()
     | `Block       -> do_block ()
     | `Unsubscribe -> do_unsubscribe ()
     | `Unblock     -> do_unblock ()
    );
    let loc = req |> Cgi.Request.abs in
    let loc = Uri.add_query_param' loc ("resource", todo_id |> Uri.to_string) in
    Logr.debug (fun m -> m "%s.%s %a 302 back to %a" "Iweb.Actor" "post" Uuidm.pp uuid Uri.pp loc);
    loc |> Http.s302 |> Lwt.return

  module Icon = struct
    (* forward to the avatar image of the id with explicit cache duration set by .htaccess/webserver config *)
    let get ~base uuid (r : Cgi.Request.t) =
      Logr.debug (fun m -> m "%s.%s" "Iweb.Actor.Icon" "get");
      let query = r.query_string |> Uri.query_of_encoded in
      match query with
      | ["resource",[u]] ->
        (let*% pk =  Ap.PubKeyPem.(private_of_pem pk_pem)
                     |> Result.map_error (fun e ->
                         Logr.warn (fun m -> m "%s.%s %s" "Iweb.Actor.Icon" "get" e);
                         Http.s500')
         in
         let date = Ptime_clock.now () in
         let base = base () in
         let key_id = Ap.Person.my_key_id ~base in
         let key = Some (Http.Signature.mkey ~now:date key_id pk) in
         let%lwt act =
           u
           |> Uri.of_string
           |> Ap.Actor.http_get ~key in
         let*% p = act
                   |> Result.map_error (fun s ->
                       Logr.warn (fun m -> m "%s.%s %a %s" "Iweb.Avatar" "get" Uuidm.pp uuid s);
                       Http.s502' ~body:(s |> Cgi.Response.body ~ee:E.e1043) ()) in
         (match p.icon with
          | [] ->  Http.s400 ()
          | i :: _ -> i
                      |> Http.s302
         ) |> Lwt.return)
      | _ -> Http.s404
             |> Lwt.return
  end
end

module Health = struct
  let path = "/actor"
  let get ~base _uuid (Auth.Uid uid, (_r : Cgi.Request.t)) =
    let base = base () in
    let to_rdf ?(tz = 0) (me : Rfc7565.t) (pem_url,x509) (cur,err,new_,run,tmp,wait) (ci_cur,ci_new) lock : _ Xmlm.frag =
      let _ = tz in
      let open Xml in
      let sep n = `Data ("\n" ^ String.make (2*n) ' ') in
      let txt ?(datatype = None) (ns,tn) (s : string) =
        `El (((ns, tn), match datatype with
          | Some ty -> [((ns_rdf, "datatype"), ty)]
          | None    -> []), [`Data s]) in
      let intg (ns,tn) (v : int) =
        `El (((ns, tn),
              [((ns_rdf, "datatype"), ns_xsd ^ "integer")]),
             [`Data (v |> Int.to_string)]) in
      let dati ?(tz_offset_s = 0) (ns,tn) (v : Ptime.t option) =
        `El (((ns, tn),
              [((ns_rdf, "datatype"), ns_xsd ^ "dateTime")]),
             [`Data (match v with
                  | None   -> "-"
                  | Some v -> v |> Ptime.to_rfc3339 ~tz_offset_s)]) in
      `El (((ns_rdf, "RDF"),
            [
              ((Xmlm.ns_xmlns, "rdf"), ns_rdf);
              ((Xmlm.ns_xmlns, "seppo"), ns_seppo);
              ((Xmlm.ns_xmlns, "b"), ns_backoffice);
            ]),
           [sep 0;
            `El (((ns_rdf, "Description"),
                  [((ns_rdf,"about"),"")]), [
                   sep 1; txt  (ns_backoffice, "rfc7565")    (me |> Rfc7565.to_string);
                   sep 1; txt  (ns_backoffice, "x509_pem_url") (pem_url |> Uri.to_string);
                   sep 1; txt  (ns_backoffice, "x509_fingerprint") (x509 |> X509.Public_key.fingerprint |> Ohex.encode);
                   sep 1; txt  (ns_backoffice, "x509_id") (x509 |> X509.Public_key.id |> Ohex.encode);
                   sep 1; dati (ns_backoffice, "q_lock")          lock;
                   sep 1; intg (ns_backoffice, "spool_job_cur")   cur;
                   sep 1; intg (ns_backoffice, "spool_job_err")   err;
                   sep 1; intg (ns_backoffice, "spool_job_new")   new_;
                   sep 1; intg (ns_backoffice, "spool_job_run")   run;
                   sep 1; intg (ns_backoffice, "spool_job_tmp")   tmp;
                   sep 1; intg (ns_backoffice, "spool_job_wait")  wait;
                   sep 1; intg (ns_backoffice, "cache_inbox_new") ci_new;
                   sep 1; intg (ns_backoffice, "cache_inbox_cur") ci_cur;
                 ] )]) in
    let pat = Str.regexp {|.+\.\(s\|json\)$|} in
    let count dn =
      let pred f = Str.string_match pat f 0 in
      dn |> File.count_dir ~pred in
    let spool_job = (
      "app/var/spool/job/cur/" |> count,
      "app/var/spool/job/err/" |> count,
      "app/var/spool/job/new/" |> count,
      "app/var/spool/job/run/" |> count,
      "app/var/spool/job/tmp/" |> count,
      "app/var/spool/job/wait/"|> count
    )
    and cache_inbox = (
      "app/var/cache/inbox/cur/" |> count,
      "app/var/cache/inbox/new/" |> count
    )
    and qt = try
        (Main.Queue.run_fn
         |> Unix.stat).st_mtime
        |> Ptime.of_float_s
      with | _ -> None
    and x509 = Ap.PubKeyPem.target
               |> File.to_string
               |> Ap.PubKeyPem.of_pem
               |> Result.get_ok
    and me = Rfc7565.(make ~local:uid ~domain:(Uri.host base |> Option.value ~default:"") ()) in
    let x = to_rdf me (Ap.PubKeyPem.target |> Uri.of_string |> Http.reso ~base,x509) spool_job cache_inbox qt in
    let xsl = "backoffice.xsl" in

    let xsl = Some ("../../themes/current/" ^ xsl) in
    Ok (`OK, [Http.H.ct_xml], Xml.to_chan ~xsl x)
end

module Http_ = struct
  let path = "/http"
  let get ~base uuid now (Auth.Uid _, (r : Cgi.Request.t)) =
    let query = r.query_string |> Uri.query_of_encoded in
    let u = Uri.make ~query () in
    Logr.debug (fun m -> m "%s.%s %a %a" "Iweb.Http_" "get" Uuidm.pp uuid Uri.pp_hum u);
    let (let*%) = Http.(let*%) in
    let*% u = "get" |> Http.par1 u in
    let base  = base () in
    let keyid = Ap.Person.my_key_id ~base in
    let*% pk = Ap.PubKeyPem.(private_of_pem pk_pem) |> Result.map_error (fun s ->
        Logr.err (fun m -> m "%s %s.%s %s" E.e1009 "Iweb.Http_" "get" s);
        Http.s500') in
    Logr.debug (fun m -> m "%s.%s my keyid %a" "Iweb.Http_" "get" Uri.pp_hum keyid);
    let key = Some (Http.Signature.mkey ~now keyid pk) in

    let headers = [ Http.H.acc_app_jlda ] |> Cohttp.Header.of_list in
    let%lwt p = u
                |> Uri.of_string
                |> Http.get ~key ~headers in
    let*% (r,b) = p
                  |> Result.map_error (fun e ->
                      Logr.warn (fun m -> m "%s.%s %a responded %s" "Iweb.Http_" "get" Uuidm.pp uuid e);
                      Http.s422' ) in
    match r.status with
    | #Cohttp.Code.success_status ->
      let ct = "content-type"
               |> Cohttp.Header.get r.headers
               |> Option.value ~default:Http.Mime.text_plain
               |> Http.H.content_type in
      let%lwt b = b |> Cohttp_lwt.Body.to_string in
      Ok (`OK, [ct], Cgi.Response.body b)
      |> Lwt.return
    | s ->
      let s = s |> Cohttp.Code.string_of_status in
      Logr.warn (fun m -> m "%s.%s %a responded %a" "Iweb.Http_" "get" Uuidm.pp uuid Http.pp_status r.status);
      Http.s502 ~body:(s |> Cgi.Response.body ~ee:E.e1044) ()
      |> Lwt.return
end

(*
module Note = struct
  let path = "/note"

  (**
     curl -L https://example.org/seppo.cgi/note?id=https://digitalcourage.social/users/mro/statuses/111601127682690078
  *)
  let get uuid (token, (Auth.Uid _uid, (r : Cgi.Request.t))) : Cgi.Response.t' =
    let que = Ap.Note.ibc_dir in
    let query = r.query_string |> Uri.query_of_encoded in
    let u = Uri.make ~query () in
    Logr.debug (fun m -> m "%s.%s %a data %a" "Iweb.Note" "get" Uuidm.pp uuid Uri.pp_hum u);
    let _ = token in
    match Option.bind
            ("h" |> Uri.get_query_param u)
            (fun h ->
               Logr.debug (fun m -> m "%s.%s %s" "Iweb.Note" "get" h);
               try
                 Ok (`OK, [Http.H.ct_jlda],
                     Scanf.sscanf h "%[a-zA-Z0-9_-]" (fun a -> a)
                     |> Printf.sprintf "%s%snote-%s.json" que "new/"
                     |> File.to_string
                     |> Cgi.Response.body)
                 |> Option.some
               with _ -> None) with
    | Some v -> v
    | None   ->
      match Option.bind
              ("id" |> Uri.get_query_param u)
              (fun id ->
                 let h = id
                         |> Uri.of_string
                         |> Ap.Note.uhash in
                 let u = Uri.remove_query_param u "id" in
                 Uri.add_query_param u ("h",[h])
                 |> Uri.to_string
                 |> Http.s302
                 |> Option.some ) with
      | None   -> Http.s404
      | Some v -> v
end
*)

module Profile = struct
  let path = "/profile"
  module F = Html.Form

  let i_tok : F.input = ("token",          "hidden",   [])
  let i_tit : F.input = ("title",          "text",     [ ("required","required"); ("minlength","1"); ("maxlength","100"); ("placeholder","A one-liner describing this #Seppo!"); ])
  let i_bio : F.input = ("bio",            "textarea", [                          ("maxlength","2000"); ("rows","10"); ("placeholder","more text describing this #Seppo!"); ])
  let i_tzo : F.input = ("timezone",       "text",     [ ("required","required"); ("minlength","3"); ("maxlength","100"); ("placeholder","Europe/Amsterdam or what timezone do you usually write from"); ])
  let i_lng : F.input = ("language",       "text",     [ ("required","required"); ("minlength","2"); ("maxlength","2"); ("pattern", {|^[a-z]+$|}); ("placeholder","nl or what language do you usually write in"); ])
  let i_ppp : F.input = ("posts_per_page", "number",   [ ("required","required"); ("min","10"); ("max","1000"); ("placeholder","50 or how many posts should go on one page"); ])
  let i_but : F.input = ("save",           "submit",   [])

  let get _uuid (token, (_uid, _req)) : Cgi.Response.t' =
    let p = Cfg.Profile.(load fn) in
    let rz = [] in
    let _ = rz |> List.fold_left (fun _ (r : Make.t) -> Make.make rz r.target) (Ok "") in
    Ok (`OK, [Http.H.ct_xml], (fun oc ->
        let Rfc4287.Rfc4646 lng = p.language in
        [
          n i_tok token;
          n i_tit p.title;
          n i_bio p.bio;
          n i_lng lng;
          n i_tzo (Timedesc.Time_zone.name p.timezone);
          n i_ppp (string_of_int p.posts_per_page);
          n i_but "Save";
        ]
        |> xhtmlform "🎭 Profile" "configform" [i_tok;i_tit;i_bio;i_lng;i_tzo;i_ppp;i_but] []
        |> to_channel ~xsl:"configform.xsl" oc))

  let post _uuid _tnow (_tok, (frm, (Auth.Uid _uid, (_req : Cgi.Request.t)))) =
    let run () =
      Logr.debug (fun m -> m "%s.%s save" "Iweb.Profile" "post");
      let* title   = F.string i_tit frm in
      let* bio     = frm |> F.string i_bio in
      let* language= F.string i_lng frm in
      let language = Rfc4287.Rfc4646 language in
      let* timezone= F.string i_tzo frm in
      let timezone = Timedesc.Time_zone.(make timezone
                                         |> Option.value ~default:Rfc3339.fallback) in
      let* ppp = F.string i_ppp frm in
      let posts_per_page = ppp
                           |> int_of_string_opt
                           |> Option.value ~default:50 in
      let p : Cfg.Profile.t = {title;bio;language;timezone;posts_per_page} in
      let eee e = ("",e) in
      let* _ = Result.map_error eee Cfg.Profile.(p |> to_file fn) in
      let* _ = Result.map_error eee Ap.Person.(Make.make rz rule.target) in
      let* _ = Result.map_error eee Ap.PersonX.(Make.make rz rule.target) in
      let* ba = Result.map_error eee Cfg.Base.(from_file fn) in
      Ok (p,ba) in
    match run() with
    | Ok (_profile,_base) ->
      pa |> Http.s302
    | Error ("",e) ->
      Logr.err (fun m -> m "%s %s.%s %s" E.e1024 "Iweb.Profile" "post" e);
      Http.s500
    | Error (_f,e) ->
      Logr.err (fun m -> m "%s %s.%s %s" E.e1025 "Iweb.Profile" "post" e);
      Ok (`Unprocessable_entity, [Http.H.ct_xml], (fun oc ->
          frm
          |> xhtmlform "🎭 Profile" "configform" [i_tok;i_tit;i_bio;i_lng;i_tzo;i_ppp;i_but] []
          |> to_channel ~xsl:"configform.xsl" oc))
end

module Announce = struct
  let path = "/activitypub/announce"

  let enqueue ~que ~due ~inbox ~msg_id j =
    j
    |> Main.Apjob.Notify.encode msg_id (inbox, msg_id)
    |> Csexp.to_string
    |> Bytes.of_string
    |> Job.enqueue ~due que 0

  (** Announce an object to all your subscribers.

      - extract object id and owner inbox to report to from get parameters
      - build announce activity json payload
      - queue delivery to owner and followers
  *)
  let get ~base
      ?(que = Main.Queue.qn)
      ?(undo = false)
      ?(cdb = Ap.Followers.cdb)
      uuid tnow (_token, (_uid, (req : Cgi.Request.t))) =
    Logr.debug (fun m -> m "%s.%s %a %s" "Iweb.Announce" "get" Uuidm.pp uuid req.query_string);
    let base = base () in
    let me = Uri.make ~path:Ap.proj () |> Http.reso ~base in
    (** the activity to send out *)
    let build_json ~base ~me id =
      let to_rfc3339 = Ptime.to_rfc3339 in
      let path       = "announce"
      and fragment   = tnow |> to_rfc3339 in
      let li : As2_vocab.Types.announce = {
        id        = Uri.make ~path ~fragment () |> Http.reso ~base;
        actor     = me;
        obj       = id;
        to_       = [As2_vocab.Constants.ActivityStreams.public];
        cc        = [];
        published = None;
      } in
      match undo with
      | false -> li |> As2_vocab.Encode.announce ~base
      | true  -> ({
          id        = Uri.with_path li.id "undo" |> Http.reso ~base;
          actor     = li.actor;
          obj       = li;
          published = None;
        } : As2_vocab.Types.announce As2_vocab.Types.undo) |>
                 As2_vocab.Encode.(undo ~base (announce ~base))
    in
    (* param names must match usage in posts.xsl *)
    let pq = Uri.make ~query:(req.query_string |> Uri.query_of_encoded) () in
    let* (id,inbox) = ("id","inbox") |> Http.par2 pq >>= Http.f2 in
    Logr.debug (fun m -> m "%s.%s %a id: %a inbox: %a" "Iweb.Announce" "get" Uuidm.pp uuid Uri.pp id Uri.pp inbox);
    let json = id |> build_json ~base ~me in
    match cdb |> Ap.Followers.(fold_left (State.ibox' (Main.fldbl_notify ~due:tnow ~que id json))) (Ok ()) with
    | Error _ -> Http.s500
    | Ok () ->       (* ideally to the referer *)
      "../timeline/p/"  |> Uri.of_string |> Http.s302
end

module Like = struct
  let path = "/activitypub/like"

  let enqueue = Announce.enqueue

  let get ~base
      ?(que = Main.Queue.qn)
      ?(undo = false)
      uuid tnow (_token, (_uid, (req : Cgi.Request.t))) =
    Logr.debug (fun m -> m "%s.%s %a %s" "Iweb.Like" "get" Uuidm.pp uuid req.query_string);
    let base = base () in
    let me = Uri.make ~path:Ap.proj () |> Http.reso ~base in
    (** the activity to send out *)
    let build_json ~base ~me id =
      let to_rfc3339 = Ptime.to_rfc3339 in
      let path       = "like"
      and fragment   = tnow |> to_rfc3339 in
      let li : As2_vocab.Types.like = {
        id        = Uri.make ~path ~fragment () |> Http.reso ~base;
        actor     = me;
        obj       = id;
      } in
      match undo with
      | false -> li |> As2_vocab.Encode.like ~base
      | true  -> ({
          id        = Uri.with_path li.id "undo" |> Http.reso ~base;
          actor     = li.actor;
          obj       = li;
          published = None;
        } : As2_vocab.Types.like As2_vocab.Types.undo) |>
                 As2_vocab.Encode.(undo ~base (like ~base))
    in
    (* param names must match usage in posts.xsl *)
    let pq = Uri.make ~query:(req.query_string |> Uri.query_of_encoded) () in
    let* (id,inbox) = ("id","inbox") |> Http.par2 pq >>= Http.f2 in
    Logr.debug (fun m -> m "%s.%s %a id: %a inbox: %a" "Iweb.Like" "get" Uuidm.pp uuid Uri.pp id Uri.pp inbox);
    match id
          |> build_json ~base ~me
          |> enqueue ~que ~due:tnow ~msg_id:id ~inbox with
    | Error _ -> Http.s500
    | Ok _ ->       (* ideally the referer *)
      "../timeline/p/"  |> Uri.of_string |> Http.s302
end

(** HTTP endpoint for a post or note, a single small message. *)
module Post = struct
  let path = "/post"
  module F = Html.Form

  let epoch_shaarli = ((2011,9,13),((15,45,42),2*60*60))
                      |> Ptime.of_date_time
                      |> Option.value ~default:Ptime.min

  let s2d ?(tz_offset_s = 0) s =
    Scanf.sscanf
      s
      "%4i%2i%2i_%2i%2i%2i"
      (fun y m d ho mi se -> ((y,m,d),((ho,mi,se),tz_offset_s)) |> Ptime.of_date_time)

  let d2s ?(tz_offset_s = 0) d =
    let ((y,m,d),((ho,mi,se),_)) = Ptime.to_date_time ~tz_offset_s d in
    Printf.sprintf "%04i%02i%02i_%02i%02i%02i" y m d ho mi se

  type cmd = Cancel | Delete | Save

  type t = {
    scrape : bool;
    source : string option;
    dat    : Ptime.t option;
    url    : Uri.t option;
    tit    : string option;
    dsc    : string option;
    tag    : string list;
    pri    : bool;
    sav    : cmd option;
    can    : string option;
    tok    : string;
    ret    : Uri.t option;
    img    : Uri.t option;
  }

  let empty = {
    scrape = false;
    source = None;
    dat    = None;
    url    = None;
    tit    = None;
    dsc    = None;
    tag    = [];
    pri    = false;
    sav    = None;
    can    = None;
    tok    = "";
    ret    = None;
    img    = None;
  }

  let to_rfc4287
      ?(now = Ptime_clock.now ())
      ?(lang = Rfc4287.Rfc4646 "nl")
      ?(author = Rfc4287.Person.empty)
      ?(tz = Rfc3339.fallback)
      r =
    let dat = r.dat |> Option.value ~default:now |> Rfc3339.of_ptime ~tz in
    let lks = match r.url with
      | None   -> []
      | Some l ->
        assert (l |> Uri.host|> Option.is_some);
        [ Rfc4287.Link.make l ] in
    let os = Option.value ~default:"" in
    Ok {Rfc4287.Entry.empty with
        (* assumes an antry has one language for title, tags, content. *)
        lang;
        author;
        title      = r.tit |> os;
        published  = dat;
        updated    = dat;
        links      = lks;
        categories = r.tag |> List.fold_left ( fun i s ->
            let l = Rfc4287.Category.Label (Rfc4287.Single s) in
            let t = Rfc4287.Category.Term (Rfc4287.Single s) in
            (l,t,Uri.empty) :: i) [];
        content    = r.dsc |> os;
       }

  let of_rfc4287
      tpl (e : Rfc4287.Entry.t) : t =
    let tit = Some e.title in
    let date t0 t =
      let Rfc3339.T t = t in
      match Ptime.of_rfc3339 t with
      | Error _       -> t0
      | Ok (t,_tz,_c) -> Some t
    in
    let dat = date tpl.dat e.published in
    let url = List.fold_left (fun init (u : Rfc4287.Link.t) ->
        match init with
        | Some _ as v -> v (* found the link, just pass it *)
        | None ->
          match u.rel with
          | None -> Some u.href
          | _    -> None) None e.links in
    let dsc = Some e.content in
    (* TODO: ensure no tags get lost *)
    {tpl with dat;url;tit;dsc}

  (** pick from the query string and set in t

      typically: r |> Uri.query |> List.fold_left sift_bookmarklet_get emp
  *)
  let sift_bookmarklet_get ?(tz = "Europe/Amsterdam") i (k,v) =
    let _ = tz in
    let v = v |> String.concat " " in
    let os v = let v = v |> String.trim in if v = "" then None else Some v
    and ou v = if "" = v then None else Some (v |> Uri.of_string) in
    match k,v with
    | "post",        v -> (
        let u = v |> Uri.of_string in
        match u |> Uri.scheme with
        | None   -> {i with tit = Some v}
        | Some _ -> {i with url = Some u})
    | "source",      v -> {i with source = os v}
    | "scrape",      v -> {i with scrape = v != "no"}
    | "title",       v -> {i with tit    = os v}
    | "tags",        v -> {i with tag    = v |> String.split_on_char ' '}
    | "image",       v -> {i with img    = ou v}
    | "description", v -> {i with dsc    = os v}
    | k,v ->
      Logr.warn (fun m -> m "%s.%s Ignored get parameter: %s='%s'" "Iweb" "sift_bookmarklet_get" k v);
      i

  let sift_post ?(tz = "Europe/Amsterdam") i (k,v) =
    let _ = tz in
    let v = v |> String.concat " " in
    let os v = let v = v |> String.trim in if v = "" then None else Some v
    and ou v = if "" = v then None else Some (v |> Uri.of_string) in
    let oau v = let u = ou v in
      Option.bind u
        (fun u' -> Option.bind (u' |> Uri.scheme)
            (fun _ -> u) )
    in
    match k,v with
    | "lf_linkdate"   , v -> {i with dat = v |> s2d }
    | "token"         , v -> {i with tok = v}
    | "returnurl"     , v -> {i with ret = ou v}
    | "lf_image"      , v -> {i with img = oau v}
    | "lf_url"        , v -> {i with url = oau v}
    | "lf_title"      , v -> {i with tit = os v}
    | "lf_description", v -> {i with dsc = os v}
    | "cancel_edit"   , ("Cancel") -> {i with sav = Some Cancel}
    | "delete_edit"   , ("Delete") -> {i with sav = Some Delete}
    | "save_edit"     , ("Save")   -> {i with sav = Some Save}
    | k               , v -> Logr.warn (fun m -> m "%s.%s %s: %s" "Iweb.Post" "sift_post" k v);
      i

  let i_id  : F.input = ("id",             "hidden",   [])
  let i_dat : F.input = ("lf_linkdate",    "hidden",   [])
  let i_url : F.input = ("lf_url",         "url",      [])
  let i_tit : F.input = ("lf_title",       "text",     [("required","required"); ("minlength","1")])
  let i_dsc : F.input = ("lf_description", "textarea", [])
  let i_tag : F.input = ("lf_tags",        "text",     [("data-multiple","data-multiple")])
  let i_pri : F.input = ("lf_private",     "checkbox", [])
  let i_sav : F.input = ("save_edit",      "submit",   [])
  let i_can : F.input = ("cancel_edit",    "submit",   [("formnovalidate","formnovalidate")])
  let i_tok : F.input = ("token",          "hidden",   [])
  let i_ret : F.input = ("returnurl",      "hidden",   [])
  let i_img : F.input = ("lf_image",       "hidden",   [])

  (** only parameter is 'post' for the message text to start with.
   * https://code.mro.name/github/Shaarli-Vanilla/src/master/index.php#L427
   * https://code.mro.name/github/Shaarli-Vanilla/src/029f75f180f79cd581786baf1b37e810da1adfc3/index.php#L1548
  *)
  let get ~base uuid (_token, (_uid, (req : Cgi.Request.t))) =
    Logr.debug (fun m -> m "%s.%s %a %s" "Iweb.Post" "get" Uuidm.pp uuid req.query_string);
    let r = req |> Cgi.Request.path_and_query
    and base = base () in
    let id = Option.bind
        ("id" |> Uri.get_query_param r)
        (fun id -> id
                   |> uri2id_rel ~base
                   |> Option.some) in
    let clz = match id with
      | Some _ -> "edit"
      | None   -> "create" in
    let now = Ptime_clock.now() in
    let emp = {empty with dat = Some now} in
    let emp =
      match id with
      | Some id ->
        assert (id |> Uri.to_string |> St.is_prefix ~affix:"o/");
        (match id |> Storage.select with
         | Error e ->
           Logr.warn (fun m -> m "%s.%s Not found: %s" "Iweb.Post" "get" e);
           emp
         | Ok e ->
           Logr.debug (fun m -> m "%s.%s Found: %a" "Iweb.Post" "get" Uri.pp id);
           of_rfc4287 emp e )
      | None -> emp in
    let r = r |> Uri.query |> List.fold_left sift_bookmarklet_get emp
    in
    (* - look up url in storage
     * - if not present:
     *   - if title not present
     *     then
     *       try to get from url
     *       use title, description, keywords
     * - show 'linkform'
    *)
    let os v = v |> Option.value ~default:"" in
    let od v = v |> Option.value ~default:epoch_shaarli |> d2s in
    let ou v = v |> Option.value ~default:Uri.empty |> Uri.to_string in
    let ol v = v |> String.concat " " in
    let ob v = if v then "on" else "no" in
    Ok (`OK, [Http.H.ct_xml], (fun oc ->
        [
          n i_id  (id |> ou);
          n i_dat (r.dat |> od);
          n i_url (r.url |> ou);
          n i_tit (r.tit |> os);
          n i_dsc (r.dsc |> os);
          n i_tag (r.tag |> ol);
          n i_pri (r.pri |> ob);
          n i_sav "save_edit";
          n i_can "cancel_edit";
          n i_tok _token;
          n i_ret (r.img |> ou);
          n i_img (r.img |> ou);
        ]
        |> xhtmlform ~clz "Add" "linkform" [i_id; i_dat;i_url;i_tit;i_dsc;i_tag;i_pri;i_sav;i_can;i_tok;i_ret;i_img;] []
        |> to_channel ~xsl:"linkform.xsl" oc))

  (** https://code.mro.name/github/Shaarli-Vanilla/src/master/index.php#L1479 *)
  let post ~base uuid _ (_tok, (frm, (Auth.Uid uid, (req : Cgi.Request.t)))) =
    Logr.debug (fun m -> m "%s.%s %a %s" "Iweb.Post" "post" Uuidm.pp uuid req.query_string);
    let base = base () in
    let f () =
      let s = frm |> Uri.with_query Uri.empty in
      Logr.debug (fun m -> m "%s.%s %a %a" "Iweb.Post" "post" Uuidm.pp uuid Uri.pp s);
      let eee e =
        Logr.warn (fun m -> m "%s.%s %a error loading Cfg.Profile: %s" "Iweb.Post" "post" Uuidm.pp uuid e);
        Http.s422' in
      let now      = Ptime_clock.now () in
      let* profile = Result.map_error eee Cfg.Profile.(from_file fn) in
      let lang     = profile.language in
      let auth_u   = Uri.make ~userinfo:uid ~host:(Uri.host base |> Option.value ~default:"example.org") () in
      let author   = {Rfc4287.Person.empty with
                      name = profile.title;
                      uri  = Some auth_u; } in
      let r = frm |> List.fold_left sift_post empty in
      let uri2id_rel ~base id =
        id
        (*        |> Uri.pct_decode *)
        (* revert substitution by posts.xsl  *)
        |> String.map (function | '$' -> '#'
                                | c   -> c)
        |> Uri.of_string
        |> Http.abs_to_rel ~base in
      match r.sav with
      | None ->
        Logr.err (fun m -> m "%s.%s %s" "Iweb.Post" "post" "None");
        Http.s500
      | Some Cancel ->
        Logr.debug (fun m -> m "%s.%s %s" "Iweb.Post" "post" "Cancel");
        pa |> Http.s302
      | Some Delete ->
        Logr.debug (fun m -> m "%s.%s %s" "Iweb.Post" "post" "Delete");
        (match req.query_string |> Uri.query_of_encoded |> List.assoc_opt "id" with
         | Some [id] ->
           let id = id |> uri2id_rel ~base in
           (match id
                  |> Main.Note.Delete.delete
              >>= Main.Note.Delete.notify_subscribers ~due:now ~base
            with
            | Error e ->
              Logr.warn (fun m -> m "%s.%s Delete %s" "Iweb.Post" "post" e);
              Http.s500
            | Ok r ->
              Logr.info (fun m -> m "TODO %s.%s Delete refresh affected files. %a" "Iweb.Post" "post" Uri.pp r.id);
              pa |> Http.s302 )
         | _ -> Http.s500)
      | Some Save ->
        let del_prev ~tz ~now (r : Rfc4287.Entry.t)  =
          match req.query_string |> Uri.query_of_encoded |> List.assoc_opt "id" with
          | Some [id] ->
            let id = id |> uri2id_rel ~base in
            Logr.debug (fun m -> m "%s.%s delete the previous entry %a %a" "Iweb.Post" "post" Uri.pp id Uri.pp r.id);
            let r = Result.bind
                (id
                 |> Main.Note.Delete.delete
                 >>= Main.Note.Delete.notify_subscribers ~due:now ~base)
                (fun old ->
                   let in_reply_to : Rfc4287.Inreplyto.t list = [Rfc4287.Inreplyto.make old.id] in
                   let updated = now |> Rfc3339.of_ptime ~tz in
                   Ok {r with updated; in_reply_to}
                ) |> Result.map_error (Http.err500 "Iweb.Post.post recreate") in
            r
          | _ ->
            Ok r
        in
        (match
           r
           |> to_rfc4287 ~tz:profile.timezone ~now ~lang ~author
           >>= del_prev ~tz:profile.timezone ~now
           >>= Main.sift_urls
           >>= Main.sift_tags Tag.cdb
           >>= Main.sift_handles
           >>= Main.Note.publish ~base ~author ~profile
           >>= Main.Note.Create.notify_subscribers ~due:now ~base
         with
         | Error e -> Error e
         | Ok _ ->
           pa |> Http.s302 )
    in
    let r = f () in
    Lwt.return r
end

module Tools = struct
  let get _uuid _ = Http.s501
end

module Session = struct
  let get _uuid (uid, _req) =
    match uid with
    | None -> (* no ban penalty but 404 nevertheless. *)
      Http.s404
    | Some (Auth.Uid v) ->
      Ok (`OK, [Http.H.ct_plain], Cgi.Response.body v)
end

(* send a potential new to-be-notified to their home server to subscribe back.
   Requires the other side to implement webfinger RFC7033 and provide
   rel=http://ostatus.org/schema/1.0/subscribe. *)
module Notifyme = struct
  let get ~base uuid _tnow (r : Cgi.Request.t) =
    assert ("http://ostatus.org/schema/1.0/subscribe" = As2_vocab.Constants.Webfinger.ostatus_rel);
    let base = base () in
    let pq = Uri.make ~query:(r.query_string |> Uri.query_of_encoded) () in
    let*% (rel,acct) = ("rel","resource") |> Http.par2 pq in
    let*% _ = if rel |> Astring.String.equal "http://ostatus.org/schema/1.0/subscribe"
      then Ok ()
      else Http.s400 () in
    Logr.debug (fun m -> m "%s.%s %a %s" "Iweb.Notifyme" "get" Uuidm.pp uuid acct);
    let*% o = acct |> Rfc7565.of_string
              |> Result.map_error (fun _ -> Http.s400' ()) in
    let wk = o |> Webfinger.well_known_uri in
    Logr.debug (fun m -> m "%s.%s %a webfinger: %a" "Iweb.Notifyme" "get" Uuidm.pp uuid Uri.pp wk);
    let%lwt wf = wk |> Webfinger.Client.http_get in
    let*% wf = wf |> Result.map_error (fun _ -> Http.s500') in
    let*% tpl = wf.links |> As2_vocab.Types.Webfinger.ostatus_subscribe
                |> Option.to_result ~none:(Http.s502' ~body:("no ostatus subscribe url found in jrd" |> Cgi.Response.body ~ee:E.e1045) ()) in
    Logr.debug (fun m -> m "%s.%s %a got template %s" "Iweb.Notifyme" "get" Uuidm.pp uuid tpl);
    let rx = Str.regexp_string "{uri}" in
    let me = Uri.make ~path:Ap.proj () |> Http.reso ~base |> Uri.to_string in
    tpl
    |> Str.replace_first rx me
    |> Uri.of_string
    |> Http.s302
    |> Lwt.return
end

module Search = struct
  let path = "/search"
  (** huhu *)
  let get ~base uuid (Auth.Uid _, (r : Cgi.Request.t)) =
    let _base = base () in
    let query = r.query_string |> Uri.query_of_encoded in
    let u = Uri.make ~query () in
    Logr.debug (fun m -> m "%s.%s %a %a" "Iweb.Actor" "get" Uuidm.pp uuid Uri.pp_hum u);
    match Uri.get_query_param u "q" with
    | Some q -> (match q |> Rfc7565.of_string with
        | Error s -> s |> Uri.of_string
        | Ok (Rfc7565.T u) -> u)
                |> Actor.redir_to
    | None -> Http.s400 ()
end

module Webfing = struct
  let path = "/webfinger"

  let can_handle ~prefix (r : Cgi.Request.t) =
    r.path_info |> St.is_prefix ~affix:prefix

  let do_handle ~prefix (r : Cgi.Request.t) =
    let s302 ~qs p = r.script_name ^ p ^ qs in
    assert ("acct" = Rfc7565.scheme);
    let wf = r.path_info |> St.after ~prefix |> Option.value ~default:"-" in
    let qs = "?resource=acct:" ^ wf ^ "&redirect=self" in
    path
    |> s302 ~qs
    |> Uri.of_string
    |> Http.s302

  (** resolve 3rd party webfinger addresses and redirect to the self link (actor fetch endpoint) *)
  let get uuid (r : Cgi.Request.t) =
    Logr.debug (fun m -> m "%s.%s %a" "Iweb.Webfing" "get" Uuidm.pp uuid);
    let ur = r |> Cgi.Request.path_and_query in
    let*% o = "resource"
              |> Uri.get_query_param ur
              |> Option.value ~default:""
              |> Rfc7565.of_string
              |> Result.map_error (fun e -> `Bad_request, [Http.H.ct_plain], Cgi.Response.body e) in
    let _ = Http.s400 () in
    let wk = o |> Webfinger.well_known_uri in
    let key = None in (* sign the get request for remote actor profile for calckey? *)
    let%lwt fi = wk |> Webfinger.Client.http_get ~key in
    let*% v = fi |> Result.map_error (fun e ->
        Logr.warn (fun m -> m "%s.%s %s" "Iweb.Webfing" "get" e);
        Http.s502' ~body:(e |> Cgi.Response.body ~ee:E.e1046) ()) in
    let*% u =  v.links
               |> As2_vocab.Types.Webfinger.self_link
               |> Option.to_result ~none:( Http.s502' ~body:("no self link found in jrd" |> Cgi.Response.body ~ee:E.e1047) ()) in
    u
    |> Actor.redir_to ~script_name:r.script_name
    |> Lwt.return
end

let flt_page ~pagesize n i _ =
  let ix = i / pagesize in
  ix == n

module Timeline = struct
  let path = "/timeline/"

  let can_handle (r : Cgi.Request.t) =
    r.path_info |> St.is_prefix ~affix:path

  let get ~tz ~base _uuid now (Auth.Uid u, (r : Cgi.Request.t)) =
    assert (not (u |> String.equal ""));
    let t0 = Sys.time() in
    let dt_s = 90. *. 24. *. 60. *. 60. in
    let tmin = (now |> Ptime.to_float_s) -. dt_s in
    let pagesize = 50
    and is_old t = t < tmin
    and base = base () in
    let p1 = "note-%.json" |> Make.Jig.make in
    let dir = "app/var/cache/inbox/new/" in
    let l = dir
            |> File.fold_dir (fun i fn ->
                match fn |> Make.Jig.cut p1 with
                | Some [_] ->
                  let fn = dir ^ fn in
                  (try let t = (Unix.stat fn).st_mtime in
                     if is_old t
                     then (Logr.info (fun m -> m "%s.%s unlink outdated: %s" "Iweb.Timeline" "get" fn);
                           Unix.unlink fn;
                           i)
                     else
                       (t,fn) :: i
                   with | e -> Logr.warn (fun m -> m "%s.%s %a" "Iweb.Timeline" "get" St.pp_exc e );
                     i) , true
                | _ -> (i,true)) [] in
    let pagecount =
      let int_ceil denominator numerator =
        (* ceil (numerator / denominator) *)
        assert (denominator > 0);
        assert (numerator >= 0);
        match numerator with
        | 0   -> 0
        | num -> succ ((pred num) / denominator) in
      l |> List.length |> int_ceil pagesize
    in
    let p_url p =
      p
      |> Printf.sprintf "seppo.cgi/timeline/p-%i/"
      |> Uri.of_string in
    let p0 = (path ^ "p-%/") |> Make.Jig.make in
    match r.path_info |> Make.Jig.cut p0 with
    | Some [pag'] -> (
        let* pag = pag' |> int_of_string_opt
                   |> Option.to_result ~none:Http.(`Not_found, [ H.ct_plain ], R.nobody) in
        let l = l
                |> List.sort (fun (t0,_n0) (t1,_n1) -> Float.compare t0 t1)
                |> List.filteri (flt_page ~pagesize pag)
                |> List.filter_map (fun (_mtime,fn) ->
                    match fn |> File.in_channel Ezjsonm.from_channel_result  with
                    | Error e ->
                      Logr.warn (fun m -> m "%s.%s ignored json error in %s: %a" "Iweb.Timeline" "get" fn St.pp_json_err e);
                      None
                    | Ok bo ->
                      match bo |> As2_vocab.Activitypub.Decode.obj with
                      | Error e ->
                        Logr.warn (fun m -> m "%s.%s ignored error in %s: %a" "Iweb.Timeline" "get" fn Decoders_ezjsonm.Decode.pp_error e);
                        None
                      | Ok ( `Update { obj = `Note obj; _ } )
                      | Ok ( `Create { obj = `Note obj; _ } ) ->
                        Some (obj |> Ap.Note.to_rfc4287 ~tz ~now)
                      | Ok (_ : As2_vocab.Types.obj)  ->
                        Logr.warn (fun m -> m "%s.%s ignored object in %s" "Iweb.Timeline" "get" fn);
                        None
                  ) in
        let p_url' p =
          if 0 <= p && p < pagecount
          then Some (p_url p)
          else None
        in
        let nu = l |> List.length in
        let first = pagecount |> pred |> p_url
        and prev  = pag |> succ |> p_url'
        and next  = pag |> pred |> p_url'
        and last  = 0 |> p_url
        and self  = pag |> p_url
        and title = Printf.sprintf "Timeline %i/%i" (succ pag) pagecount
        in
        let x = l |> Rfc4287.Feed.to_atom
                  ~base
                  ~self
                  ~prev
                  ~next
                  ~first
                  ~last
                  ~title
                  ~updated:Rfc3339.epoch
                  ~lang:(Rfc4287.Rfc4646 "nl")
                  ~author:Rfc4287.Person.empty in
        let xsl = "timeline.xsl" in
        let xsl = Some ("../../../themes/current/" ^ xsl) in
        Logr.debug (fun m -> m "%s.%s dt=%fs page %i/%i %i items" "Iweb.Timeline" "get" (Sys.time () -. t0) pag pagecount nu);
        Ok (`OK, [Http.H.ct_xml], Xml.to_chan ~xsl x) )
    | _ -> pagecount
           |> pred
           |> p_url
           |> Http.reso ~base
           |> Http.s302
end
